home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / TYPE.LSP < prev    next >
Lisp/Scheme  |  1994-02-05  |  34KB  |  834 lines
  1. ;;;; TYPEP und Verwandtes
  2. ;;;; Michael Stoll, 21. 10. 1988
  3. ;;;; Bruno Haible, 10.6.1989
  4.  
  5. ;;; Datenstrukturen für TYPEP:
  6. ;;; - Ein Type-Specifier-Symbol hat auf seiner Propertyliste unter dem
  7. ;;;   Indikator SYS::TYPE-SYMBOL eine Funktion von einem Argument, die
  8. ;;;   testet, ob ein Objekt vom richtigen Typ ist.
  9. ;;; - Ein Symbol, das eine Type-Specifier-Liste beginnen kann, hat auf seiner
  10. ;;;   Propertyliste unter dem Indikator SYS::TYPE-LIST eine Funktion von
  11. ;;;   einem Argument für das zu testende Objekt und zusätzlichen Argumenten
  12. ;;;   für die Listenelemente.
  13. ;;; - Ein Symbol, das als Typmacro definiert wurde, hat auf seiner Property-
  14. ;;;   liste unter dem Indikator SYSTEM::DEFTYPE-EXPANDER den zugehörigen
  15. ;;;   Expander: eine Funktion, die den zu expandierenden Type-Specifier (eine
  16. ;;;   mindestens einelementige Liste) als Argument bekommt.
  17.  
  18. (in-package "SYSTEM")
  19.  
  20. ; vorläufig, solange bis clos.lsp geladen wird:
  21. (defun clos::built-in-class-p (object) (declare (ignore object)) nil)
  22. (defun clos::subclassp (class1 class2) (declare (ignore class1 class2)) nil)
  23.  
  24. (defun type-error (fun type)
  25.   (error #+DEUTSCH "~S: ~S ist keine zugelassene Typspezifikation."
  26.          #+ENGLISH "~S: invalid type specification ~S"
  27.          #+FRANCAIS "~S : ~S n'est pas une spécification de type légale."
  28.          fun type
  29. ) )
  30.  
  31. ;;; TYPEP, CLTL S. 72, S. 42-51
  32. (defun typep (x y &aux f) ; x = Objekt, y = Typ
  33.   (cond
  34.     ((symbolp y)
  35.        (cond ((setq f (get y 'TYPE-SYMBOL)) (funcall f x))
  36.              ((setq f (get y 'TYPE-LIST)) (funcall f x))
  37.              ((setq f (get y 'DEFTYPE-EXPANDER)) (typep x (funcall f (list y))))
  38.              ((get y 'DEFSTRUCT-DESCRIPTION) (%STRUCTURE-TYPE-P y x))
  39.              ((and (setf f (get y 'CLOS::CLASS))
  40.                    (clos::class-p f)
  41.                    (eq (clos:class-name f) y)
  42.               )
  43.               (clos::subclassp (clos:class-of x) f)
  44.              )
  45.              (t (type-error 'typep y))
  46.     )  )
  47.     ((and (consp y) (symbolp (first y)))
  48.        (cond
  49.          ((and (eq (first y) 'SATISFIES) (eql (length y) 2))
  50.             (unless (symbolp (second y))
  51.               (error #+DEUTSCH "~S: Argument zu SATISFIES muß Symbol sein: ~S"
  52.                      #+ENGLISH "~S: argument to SATISFIES must be a symbol: ~S"
  53.                      #+FRANCAIS "~S : L'argument de SATISFIES doit être un symbole: ~S"
  54.                      'typep (second y)
  55.             ) )
  56.             (if (funcall (symbol-function (second y)) x) t nil)
  57.          )
  58.          ((eq (first y) 'MEMBER)
  59.             (if (member x (rest y)) t nil)
  60.          )
  61.          ((and (eq (first y) 'EQL) (eql (length y) 2))
  62.             (eql x (second y))
  63.          )
  64.          ((and (eq (first y) 'NOT) (eql (length y) 2))
  65.             (not (typep x (second y)))
  66.          )
  67.          ((eq (first y) 'AND)
  68.             (dolist (type (rest y) t)
  69.               (unless (typep x type) (return nil))
  70.          )  )
  71.          ((eq (first y) 'OR)
  72.             (dolist (type (rest y) nil)
  73.               (when (typep x type) (return t))
  74.          )  )
  75.          ((setq f (get (first y) 'TYPE-LIST)) (apply f x (rest y)))
  76.          ((setq f (get (first y) 'DEFTYPE-EXPANDER)) (typep x (funcall f y)))
  77.          (t (type-error 'typep y))
  78.     )  )
  79.     ((clos::class-p y) (clos::subclassp (clos:class-of x) y))
  80.     (t (type-error 'typep y))
  81. ) )
  82.  
  83. ; CLTL S. 43
  84. (%put 'ARRAY 'TYPE-SYMBOL #'arrayp)
  85. (%put 'ATOM 'TYPE-SYMBOL #'atom)
  86. (%put 'BIGNUM 'TYPE-SYMBOL
  87.   (function type-symbol-bignum
  88.     (lambda (x) (and (integerp x) (not (fixnump x))))
  89. ) )
  90. (%put 'BIT 'TYPE-SYMBOL
  91.   (function type-symbol-bit
  92.     (lambda (x) (or (eql x 0) (eql x 1)))
  93. ) )
  94. (%put 'BIT-VECTOR 'TYPE-SYMBOL #'bit-vector-p)
  95. (%put 'CHARACTER 'TYPE-SYMBOL #'characterp)
  96. (%put 'COMMON 'TYPE-SYMBOL #'commonp)
  97. (%put 'COMPILED-FUNCTION 'TYPE-SYMBOL #'compiled-function-p)
  98. (%put 'COMPLEX 'TYPE-SYMBOL #'complexp)
  99. (%put 'CONS 'TYPE-SYMBOL #'consp)
  100. (%put 'DOUBLE-FLOAT 'TYPE-SYMBOL #'double-float-p)
  101. (%put 'FIXNUM 'TYPE-SYMBOL #'fixnump)
  102. (%put 'FLOAT 'TYPE-SYMBOL #'floatp)
  103. (%put 'FUNCTION 'TYPE-SYMBOL #'functionp)
  104. (%put 'HASH-TABLE 'TYPE-SYMBOL #'hash-table-p)
  105. (%put 'INTEGER 'TYPE-SYMBOL #'integerp)
  106. (%put 'KEYWORD 'TYPE-SYMBOL #'keywordp)
  107. (%put 'LIST 'TYPE-SYMBOL #'listp)
  108. (%put 'LONG-FLOAT 'TYPE-SYMBOL #'long-float-p)
  109. (%put 'NIL 'TYPE-SYMBOL
  110.   (function type-symbol-nil
  111.     (lambda (x) (declare (ignore x)) nil)
  112. ) )
  113. (%put 'NULL 'TYPE-SYMBOL #'null)
  114. (%put 'NUMBER 'TYPE-SYMBOL #'numberp)
  115. (%put 'PACKAGE 'TYPE-SYMBOL #'packagep)
  116. (%put 'PATHNAME 'TYPE-SYMBOL #'pathnamep)
  117. (%put 'RANDOM-STATE 'TYPE-SYMBOL #'random-state-p)
  118. (%put 'RATIO 'TYPE-SYMBOL
  119.   (function type-symbol-ratio
  120.     (lambda (x) (and (rationalp x) (not (integerp x))))
  121. ) )
  122. (%put 'RATIONAL 'TYPE-SYMBOL #'rationalp)
  123. (%put 'READTABLE 'TYPE-SYMBOL #'readtablep)
  124. (%put 'REAL 'TYPE-SYMBOL #'realp)
  125. (%put 'SEQUENCE 'TYPE-SYMBOL #'sequencep)
  126. (%put 'SHORT-FLOAT 'TYPE-SYMBOL #'short-float-p)
  127. (%put 'SIMPLE-ARRAY 'TYPE-SYMBOL #'simple-array-p)
  128. (%put 'SIMPLE-BIT-VECTOR 'TYPE-SYMBOL #'simple-bit-vector-p)
  129. (%put 'SIMPLE-STRING 'TYPE-SYMBOL #'simple-string-p)
  130. (%put 'SIMPLE-VECTOR 'TYPE-SYMBOL #'simple-vector-p)
  131. (%put 'SINGLE-FLOAT 'TYPE-SYMBOL #'single-float-p)
  132. (%put 'STANDARD-CHAR 'TYPE-SYMBOL
  133.   (function type-symbol-standard-char
  134.     (lambda (x) (and (characterp x) (standard-char-p x)))
  135. ) )
  136. (%put 'CLOS:STANDARD-GENERIC-FUNCTION 'TYPE-SYMBOL #'clos::generic-function-p)
  137. (%put 'CLOS:STANDARD-OBJECT 'TYPE-SYMBOL #'clos::std-instance-p)
  138. (%put 'STREAM 'TYPE-SYMBOL #'streamp)
  139. (%put 'STRING 'TYPE-SYMBOL #'stringp)
  140. (%put 'STRING-CHAR 'TYPE-SYMBOL
  141.   (function type-symbol-string-char
  142.     (lambda (x) (and (characterp x) (string-char-p x)))
  143. ) )
  144. (%put 'STRUCTURE 'TYPE-SYMBOL
  145.   (function type-symbol-structure
  146.     (lambda (x)
  147.       (let ((y (type-of x)))
  148.         (and (symbolp y) (get y 'DEFSTRUCT-DESCRIPTION)
  149.              (%STRUCTURE-TYPE-P y x)
  150. ) ) ) ) )
  151. (%put 'SYMBOL 'TYPE-SYMBOL #'symbolp)
  152. (%put 'T 'TYPE-SYMBOL
  153.   (function type-symbol-t
  154.     (lambda (x) (declare (ignore x)) t)
  155. ) )
  156. (%put 'VECTOR 'TYPE-SYMBOL #'vectorp)
  157.  
  158. ; CLTL S. 46-50
  159. (defun upgraded-array-element-type (type)
  160.   #+CLISP1 ; siehe ARRAY.Q
  161.   (case type
  162.     ((STRING-CHAR BIT) type)
  163.     (t 'T)
  164.   )
  165.   #-CLISP1 ; siehe ARRAY.D
  166.   (case type
  167.     ((BIT STRING-CHAR T) type)
  168.     (t (multiple-value-bind (low high) (sys::subtype-integer type)
  169.          ; Es gilt (or (null low) (subtypep type `(INTEGER ,low ,high))
  170.          (if (and (integerp low) (not (minusp low)) (integerp high))
  171.            (let ((l (integer-length high)))
  172.              ; Es gilt (subtypep type `(UNSIGNED-BYTE ,l))
  173.              (cond ((<= l 1) 'BIT)
  174.                    ((<= l 2) '(UNSIGNED-BYTE 2))
  175.                    ((<= l 4) '(UNSIGNED-BYTE 4))
  176.                    ((<= l 8) '(UNSIGNED-BYTE 8))
  177.                    ((<= l 16) '(UNSIGNED-BYTE 16))
  178.                    ((<= l 32) '(UNSIGNED-BYTE 32))
  179.                    (t 'T)
  180.            ) )
  181.            'T
  182.   ) )  ) )
  183. )
  184. (%put 'ARRAY 'TYPE-LIST
  185.   (function type-list-array
  186.     (lambda (x &optional (el-type '*) (dims '*))
  187.       (and (arrayp x)
  188.            (or (eq el-type '*)
  189.                (equal (array-element-type x) (upgraded-array-element-type el-type))
  190.            )
  191.            (or (eq dims '*)
  192.                (if (numberp dims)
  193.                  (eql dims (array-rank x))
  194.                  (and (eql (length dims) (array-rank x))
  195.                       (every #'(lambda (a b) (or (eq a '*) (eql a b)))
  196.                              dims (array-dimensions x)
  197.   ) ) )    )   ) )    )
  198. )
  199. (%put 'SIMPLE-ARRAY 'TYPE-LIST
  200.   (function type-list-simple-array
  201.     (lambda (x &optional (el-type '*) (dims '*))
  202.       (and (simple-array-p x)
  203.            (or (eq el-type '*)
  204.                (equal (array-element-type x) (upgraded-array-element-type el-type))
  205.            )
  206.            (or (eq dims '*)
  207.                (if (numberp dims)
  208.                  (eql dims (array-rank x))
  209.                  (and (eql (length dims) (array-rank x))
  210.                       (every #'(lambda (a b) (or (eq a '*) (eql a b)))
  211.                              dims (array-dimensions x)
  212.   ) ) )    )   ) )    )
  213. )
  214. (%put 'VECTOR 'TYPE-LIST
  215.   (function type-list-vector
  216.     (lambda (x &optional (el-type '*) (size '*))
  217.       (and (vectorp x)
  218.            (or (eq el-type '*)
  219.                (equal (array-element-type x) (upgraded-array-element-type el-type))
  220.            )
  221.            (or (eq size '*) (eql (array-dimension x 0) size))
  222.   ) ) )
  223. )
  224. (%put 'SIMPLE-VECTOR 'TYPE-LIST
  225.   (function type-list-simple-vector
  226.     (lambda (x &optional (size '*))
  227.       (and (simple-vector-p x)
  228.            (or (eq size '*) (eql size (array-dimension x 0)))
  229.   ) ) )
  230. )
  231. (%put 'COMPLEX 'TYPE-LIST
  232.   (function type-list-complex
  233.     (lambda (x &optional (rtype '*) (itype rtype))
  234.       (and (complexp x)
  235.            (or (eq rtype '*) (typep (realpart x) rtype))
  236.            (or (eq itype '*) (typep (imagpart x) itype))
  237.   ) ) )
  238. )
  239. (%put 'INTEGER 'TYPE-LIST
  240.   (function type-list-integer
  241.     (lambda (x &optional (low '*) (high '*))
  242.       (typep-number-test x low high #'integerp 'INTEGER)
  243.   ) )
  244. )
  245. (defun typep-number-test (x low high test type)
  246.   (and (funcall test x)
  247.        (cond ((eq low '*))
  248.              ((funcall test low) (<= low x))
  249.              ((and (consp low) (null (rest low)) (funcall test (first low)))
  250.                 (< (first low) x)
  251.              )
  252.              (t (error #+DEUTSCH "~S: Argument zu ~S muß *, ~S oder eine Liste von ~S sein: ~S"
  253.                        #+ENGLISH "~S: argument to ~S must be *, ~S or a list of ~S: ~S"
  254.                        #+FRANCAIS "~S : L'argument de ~S doit être *, ~S ou une liste de ~S: ~S"
  255.                        'typep type type type low
  256.        )     )  )
  257.        (cond ((eq high '*))
  258.              ((funcall test high) (>= high x))
  259.              ((and (consp high) (null (rest high)) (funcall test (first high)))
  260.                 (> (first high) x)
  261.              )
  262.              (t (error #+DEUTSCH "~S: Argument zu ~S muß *, ~S oder eine Liste von ~S sein: ~S"
  263.                        #+ENGLISH "~S: argument to ~S must be *, ~S or a list of ~S: ~S"
  264.                        #+FRANCAIS "~S : L'argument de ~S doit être *, ~S ou une liste de ~S: ~S"
  265.                        'typep type type type high
  266. ) )    )     )  )
  267. (%put 'MOD 'TYPE-LIST
  268.   (function type-list-mod
  269.     (lambda (x n)
  270.       (unless (integerp n)
  271.         (error #+DEUTSCH "~S: Argument zu MOD muß ganze Zahl sein: ~S"
  272.                #+ENGLISH "~S: argument to MOD must be an integer: ~S"
  273.                #+FRANCAIS "~S : L'argument de MOD doit être un entier: ~S"
  274.                'typep n
  275.       ) )
  276.       (and (integerp x) (<= 0 x) (< x n))
  277.   ) )
  278. )
  279. (%put 'SIGNED-BYTE 'TYPE-LIST
  280.   (function type-list-signed-byte
  281.     (lambda (x &optional (n '*))
  282.       (unless (or (eq n '*) (integerp n))
  283.         (error #+DEUTSCH "~S: Argument zu SIGNED-BYTE muß ganze Zahl oder * sein: ~S"
  284.                #+ENGLISH "~S: argument to SIGNED-BYTE must be an integer or * : ~S"
  285.                #+FRANCAIS "~S : L'argument de SIGNED-BYTE doit être un entier ou bien * : ~S"
  286.                'typep n
  287.       ) )
  288.       (and (integerp x) (or (eq n '*) (< (integer-length x) n)))
  289.   ) )
  290. )
  291. (%put 'UNSIGNED-BYTE 'TYPE-LIST
  292.   (function type-list-unsigned-byte
  293.     (lambda (x &optional (n '*))
  294.       (unless (or (eq n '*) (integerp n))
  295.         (error #+DEUTSCH "~S: Argument zu UNSIGNED-BYTE muß ganze Zahl oder * sein: ~S"
  296.                #+ENGLISH "~S: argument to UNSIGNED-BYTE must be an integer or * : ~S"
  297.                #+FRANCAIS "~S : L'argument de UNSIGNED-BYTE doit être un entier ou bien * : ~S"
  298.                'typep n
  299.       ) )
  300.       (and (integerp x)
  301.            (not (minusp x))
  302.            (or (eq n '*) (<= (integer-length x) n))
  303.   ) ) )
  304. )
  305. (%put 'REAL 'TYPE-LIST
  306.   (function type-list-real
  307.     (lambda (x &optional (low '*) (high '*))
  308.       (typep-number-test x low high #'realp 'REAL)
  309.   ) )
  310. )
  311. (%put 'RATIONAL 'TYPE-LIST
  312.   (function type-list-rational
  313.     (lambda (x &optional (low '*) (high '*))
  314.       (typep-number-test x low high #'rationalp 'RATIONAL)
  315.   ) )
  316. )
  317. (%put 'FLOAT 'TYPE-LIST
  318.   (function type-list-float
  319.     (lambda (x &optional (low '*) (high '*))
  320.       (typep-number-test x low high #'floatp 'FLOAT)
  321.   ) )
  322. )
  323. (%put 'SHORT-FLOAT 'TYPE-LIST
  324.   (function type-list-short-float
  325.     (lambda (x &optional (low '*) (high '*))
  326.       (typep-number-test x low high #'short-float-p 'SHORT-FLOAT)
  327.   ) )
  328. )
  329. (%put 'SINGLE-FLOAT 'TYPE-LIST
  330.   (function type-list-single-float
  331.     (lambda (x &optional (low '*) (high '*))
  332.       (typep-number-test x low high #'single-float-p 'SINGLE-FLOAT)
  333.   ) )
  334. )
  335. (%put 'DOUBLE-FLOAT 'TYPE-LIST
  336.   (function type-list-double-float
  337.     (lambda (x &optional (low '*) (high '*))
  338.       (typep-number-test x low high #'double-float-p 'DOUBLE-FLOAT)
  339.   ) )
  340. )
  341. (%put 'LONG-FLOAT 'TYPE-LIST
  342.   (function type-list-long-float
  343.     (lambda (x &optional (low '*) (high '*))
  344.       (typep-number-test x low high #'long-float-p 'LONG-FLOAT)
  345.   ) )
  346. )
  347. (%put 'STRING 'TYPE-LIST
  348.   (function type-list-string
  349.     (lambda (x &optional (size '*))
  350.       (and (stringp x)
  351.            (or (eq size '*) (eql size (array-dimension x 0)))
  352.   ) ) )
  353. )
  354. (%put 'SIMPLE-STRING 'TYPE-LIST
  355.   (function type-list-simple-string
  356.     (lambda (x &optional (size '*))
  357.       (and (simple-string-p x)
  358.            (or (eq size '*) (eql size (array-dimension x 0)))
  359.   ) ) )
  360. )
  361. (%put 'BIT-VECTOR 'TYPE-LIST
  362.   (function type-list-bit-vector
  363.     (lambda (x &optional (size '*))
  364.       (and (bit-vector-p x)
  365.            (or (eq size '*) (eql size (array-dimension x 0)))
  366.   ) ) )
  367. )
  368. (%put 'SIMPLE-BIT-VECTOR 'TYPE-LIST
  369.   (function type-list-simple-bit-vector
  370.     (lambda (x &optional (size '*))
  371.       (and (simple-bit-vector-p x)
  372.            (or (eq size '*) (eql size (array-dimension x 0)))
  373.   ) ) )
  374. )
  375.  
  376. ; Testet eine Liste von Werten auf Erfüllen eines Type-Specifiers. Für THE.
  377. (defun %the (values type)
  378.   (if (and (consp type) (eq (car type) 'VALUES))
  379.     (macrolet ((type-error ()
  380.                  '(error #+DEUTSCH "Falsch aufgebauter Type-Specifier: ~S"
  381.                          #+ENGLISH "Invalid type specifier ~S"
  382.                          #+FRANCAIS "Spécificateur de type mal formé : ~S"
  383.                          type
  384.               ))  )
  385.       (let ((vals values)
  386.             (types (cdr type)))
  387.         ; required-Werte:
  388.         (loop
  389.           (when (or (atom types) (member (car types) lambda-list-keywords :test #'eq))
  390.             (return)
  391.           )
  392.           (unless (and (consp vals) (typep (car vals) (car types)))
  393.             (return-from %the nil)
  394.           )
  395.           (setq vals (cdr vals))
  396.           (setq types (cdr types))
  397.         )
  398.         ; optionale Werte:
  399.         (when (and (consp types) (eq (car types) '&optional))
  400.           (setq types (cdr types))
  401.           (loop
  402.             (when (or (atom types) (member (car types) lambda-list-keywords :test #'eq))
  403.               (return)
  404.             )
  405.             (when (consp vals)
  406.               (unless (typep (car vals) (car types)) (return-from %the nil))
  407.               (setq vals (cdr vals))
  408.             )
  409.             (setq types (cdr types))
  410.         ) )
  411.         ; restliche Werte:
  412.         (if (atom types)
  413.           (when (consp vals) (return-from %the nil))
  414.           (case (car types)
  415.             (&rest
  416.               (setq types (cdr types))
  417.               (when (atom types) (type-error))
  418.               (unless (typep vals (car types)) (return-from %the nil))
  419.               (setq types (cdr types))
  420.             )
  421.             (&key)
  422.             (t (type-error))
  423.         ) )
  424.         ; Keyword-Werte:
  425.         (when (consp types)
  426.           (if (eq (car types) '&key)
  427.             (progn
  428.               (setq types (cdr types))
  429.               (when (oddp (length vals)) (return-from %the nil))
  430.               (let ((keywords nil))
  431.                 (loop
  432.                   (when (or (atom types) (member (car types) lambda-list-keywords :test #'eq))
  433.                     (return)
  434.                   )
  435.                   (let ((item (car types)))
  436.                     (unless (and (listp item) (eql (length item) 2) (symbolp (first item)))
  437.                       (type-error)
  438.                     )
  439.                     (let ((kw (intern (symbol-name (first item)) *keyword-package*)))
  440.                       (unless (typep (getf vals kw) (second item))
  441.                         (return-from %the nil)
  442.                       )
  443.                       (push kw keywords)
  444.                   ) )
  445.                   (setq types (cdr types))
  446.                 )
  447.                 (if (and (consp types) (eq (car types) '&allow-other-keys))
  448.                   (setq types (cdr types))
  449.                   (unless (getf vals ':allow-other-keys)
  450.                     (do ((L vals (cddr L)))
  451.                         ((atom L))
  452.                       (unless (member (car L) keywords :test #'eq)
  453.                         (return-from %the nil)
  454.                 ) ) ) )
  455.             ) )
  456.             (when (consp types) (type-error))
  457.         ) )
  458.         t
  459.     ) )
  460.     (typep (if (consp values) (car values) nil) type) ; 1. Wert abtesten
  461. ) )
  462.  
  463. ;;; SUBTYPEP, vorläufige Version
  464. (defun canonicalize-type (type) ; type ein wenig vereinfachen, nicht rekursiv
  465.   (cond ((symbolp type)
  466.          (let ((f (get type 'DEFTYPE-EXPANDER)))
  467.            (if f
  468.              (canonicalize-type (funcall f (list type))) ; macroexpandieren
  469.              (case type
  470.                (ATOM '(NOT CONS))
  471.                (BIGNUM '(AND INTEGER (NOT FIXNUM)))
  472.                (BIT '(INTEGER 0 1))
  473.                (COMMON '(OR CONS SYMBOL NUMBER ARRAY STANDARD-CHAR
  474.                          STREAM PACKAGE HASH-TABLE READTABLE PATHNAME RANDOM-STATE
  475.                          STRUCTURE
  476.                )        )
  477.                (FIXNUM '(INTEGER #,most-negative-fixnum #,most-positive-fixnum))
  478.                (KEYWORD '(AND SYMBOL (SATISFIES KEYWORDP)))
  479.                (LIST '(OR CONS (MEMBER NIL)))
  480.                ((NIL) '(OR))
  481.                (NULL '(MEMBER NIL))
  482.                (RATIO '(AND RATIONAL (NOT INTEGER)))
  483.                (SEQUENCE '(OR LIST VECTOR)) ; user-defined sequences??
  484.                (STANDARD-CHAR '(AND CHARACTER (SATISFIES STRING-CHAR-P) (SATISFIES STANDARD-CHAR-P)))
  485.                (STRING-CHAR '(AND CHARACTER (SATISFIES STRING-CHAR-P)))
  486.                ((T) '(AND))
  487.                ((ARRAY SIMPLE-ARRAY BIT-VECTOR SIMPLE-BIT-VECTOR
  488.                  STRING SIMPLE-STRING VECTOR SIMPLE-VECTOR
  489.                  COMPLEX REAL INTEGER RATIONAL FLOAT
  490.                  SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT
  491.                 )
  492.                  (canonicalize-type (list type))
  493.                )
  494.                (t (if (and (setq f (get type 'CLOS::CLASS))
  495.                            (clos::class-p f) (not (clos::built-in-class-p f))
  496.                            (eq (clos:class-name f) type)
  497.                       )
  498.                     f
  499.                     type
  500.         )) ) ) )  )
  501.         ((and (consp type) (symbolp (first type)))
  502.          (let ((f (get (first type) 'DEFTYPE-EXPANDER)))
  503.            (if f
  504.              (canonicalize-type (funcall f type)) ; macroexpandieren
  505.              (case (first type)
  506.                (MEMBER ; (MEMBER &rest objects)
  507.                  (if (null (rest type)) '(OR) type)
  508.                )
  509.                (EQL ; (EQL object)
  510.                  `(MEMBER ,(second type))
  511.                )
  512.                (MOD ; (MOD n)
  513.                  (let ((n (second type)))
  514.                    (unless (and (integerp n) (>= n 0)) (type-error 'subtypep type))
  515.                    `(INTEGER 0 (,n))
  516.                ) )
  517.                (SIGNED-BYTE ; (SIGNED-BYTE &optional s)
  518.                  (let ((s (or (second type) '*)))
  519.                    (if (eq s '*)
  520.                      'INTEGER
  521.                      (progn
  522.                        (unless (and (integerp s) (plusp s)) (type-error 'subtypep type))
  523.                        (let ((n (expt 2 (1- s))))
  524.                          `(INTEGER ,(- n) (,n))
  525.                ) ) ) ) )
  526.                (UNSIGNED-BYTE ; (UNSIGNED-BYTE &optional s)
  527.                  (let ((s (or (second type) '*)))
  528.                    (if (eq s '*)
  529.                      '(INTEGER 0 *)
  530.                      (progn
  531.                        (unless (and (integerp s) (>= s 0)) (type-error 'subtypep type))
  532.                        (let ((n (expt 2 s)))
  533.                          `(INTEGER 0 (,n))
  534.                ) ) ) ) )
  535.                (SIMPLE-BIT-VECTOR ; (SIMPLE-BIT-VECTOR &optional size)
  536.                  (let ((size (or (second type) '*)))
  537.                    `(SIMPLE-ARRAY BIT (,size))
  538.                ) )
  539.                (SIMPLE-STRING ; (SIMPLE-STRING &optional size)
  540.                  (let ((size (or (second type) '*)))
  541.                    `(SIMPLE-ARRAY STRING-CHAR (,size))
  542.                ) )
  543.                (SIMPLE-VECTOR ; (SIMPLE-VECTOR &optional size)
  544.                  (let ((size (or (second type) '*)))
  545.                    `(SIMPLE-ARRAY T (,size))
  546.                ) )
  547.                (BIT-VECTOR ; (BIT-VECTOR &optional size)
  548.                  (let ((size (or (second type) '*)))
  549.                    `(ARRAY BIT (,size))
  550.                ) )
  551.                (STRING ; (STRING &optional size)
  552.                  (let ((size (or (second type) '*)))
  553.                    `(ARRAY STRING-CHAR (,size))
  554.                ) )
  555.                (VECTOR ; (VECTOR &optional el-type size)
  556.                  (let ((el-type (or (second type) '*))
  557.                        (size (or (third type) '*)))
  558.                    `(ARRAY ,el-type (,size))
  559.                ) )
  560.                (t type)
  561.         )) ) )
  562.         ((clos::class-p type)
  563.          (if (and (clos::built-in-class-p type)
  564.                   (eq (get (clos:class-name type) 'CLOS::CLASS) type)
  565.              )
  566.            (canonicalize-type (clos:class-name type))
  567.            type
  568.         ))
  569. ) )
  570. (defun subtypep (type1 type2)
  571.   (macrolet ((yes () '(return-from subtypep (values t t)))
  572.              (no () '(return-from subtypep (values nil t)))
  573.              (unknown () '(return-from subtypep (values nil nil))))
  574.     (setq type1 (canonicalize-type type1))
  575.     (setq type2 (canonicalize-type type2))
  576.     (when (equal type1 type2) (yes)) ; (subtypep type type) stimmt immer
  577.     (when (consp type1)
  578.       (cond ;; über SATISFIES-Typen kann man nichts aussagen
  579.             ;((and (eq (first type1) 'SATISFIES) (eql (length type1) 2))
  580.             ; (unknown)
  581.             ;)
  582.             ;; MEMBER: alle Elemente müssen vom Typ type2 sein
  583.             ((eq (first type1) 'MEMBER)
  584.              (dolist (x (rest type1) (yes))
  585.                (unless (typep x type2) (return (no)))
  586.             ))
  587.             ;; NOT: (subtypep `(NOT ,type1) `(NOT ,type2)) ist äquivalent
  588.             ;; zu (subtypep type2 type1), sonst ist Entscheidung schwierig
  589.             ((and (eq (first type1) 'NOT) (eql (length type1) 2))
  590.              (return-from subtypep
  591.                (if (and (consp type2) (eq (first type2) 'NOT) (eql (length type2) 2))
  592.                  (subtypep (second type2) (second type1))
  593.                  (unknown)
  594.             )) )
  595.             ;; OR: Jeder Typ muß Subtyp von type2 sein
  596.             ((eq (first type1) 'OR)
  597.              (dolist (type (rest type1) (yes))
  598.                (multiple-value-bind (is known) (subtypep type type2)
  599.                  (unless is (return-from subtypep (values nil known)))
  600.             )) )
  601.     ) )
  602.     (when (consp type2)
  603.       (cond ;; über SATISFIES-Typen kann man nichts aussagen
  604.             ;((and (eq (first type2) 'SATISFIES) (eql (length type2) 2))
  605.             ; (unknown)
  606.             ;)
  607.             ;; NOT: siehe oben
  608.             ((and (eq (first type2) 'NOT) (eql (length type2) 2))
  609.              (unknown)
  610.             )
  611.             ;; AND: type1 muß Subtyp jedes der Typen sein
  612.             ((eq (first type2) 'AND)
  613.              (dolist (type (rest type2) (yes))
  614.                (multiple-value-bind (is known) (subtypep type1 type)
  615.                  (unless is (return-from subtypep (values nil known)))
  616.             )) )
  617.             ;; OR: Falls type1 Subtyp eines der Typen ist, sonst nicht bekannt
  618.             ((eq (first type2) 'OR)
  619.              (dolist (type (rest type2) (unknown))
  620.                (when (subtypep type1 type) (return (yes)))
  621.             ))
  622.     ) )
  623.     (when (consp type1)
  624.       (cond ;; AND: Falls ein Typ Subtyp von type2 ist, sonst nicht bekannt
  625.             ((eq (first type1) 'AND)
  626.              (dolist (type (rest type1) (unknown))
  627.                (when (subtypep type type2) (return (yes)))
  628.             ))
  629.     ) )
  630.     (when (and (symbolp type1) (get type1 'DEFSTRUCT-DESCRIPTION)
  631.                (symbolp type2)
  632.           )
  633.       (when (eq type2 'STRUCTURE) (yes))
  634.       (when (get type2 'DEFSTRUCT-DESCRIPTION)
  635.         (let ((inclist1 (svref (get type1 'DEFSTRUCT-DESCRIPTION) 0))
  636.               (inclist2 (svref (get type2 'DEFSTRUCT-DESCRIPTION) 0)))
  637.           (loop
  638.             (when (eq inclist1 inclist2) (return (yes)))
  639.             (when (atom inclist1) (return))
  640.             (setq inclist1 (cdr inclist1))
  641.       ) ) )
  642.     )
  643.     (when (or (clos::class-p type1) (clos::class-p type2))
  644.       (if (and (clos::class-p type1) (clos::class-p type2) (clos::subclassp type1 type2))
  645.         (yes)
  646.         (no)
  647.     ) )
  648.     (when (atom type1) (setq type1 (list type1)))
  649.     (case (first type1)
  650.       ((ARRAY SIMPLE-ARRAY)
  651.         (macrolet ((array-p (type)
  652.                      `(or (eq ,type 'ARRAY) (eq ,type (first type1)))
  653.                   ))
  654.           (let ((el-type1 (if (rest type1) (second type1) '*))
  655.                 (dims1 (if (cddr type1) (third type1) '*)))
  656.             (values
  657.               (cond ((array-p type2) t)
  658.                     ((and (consp type2) (array-p (first type2)))
  659.                      (let ((el-type2 (if (rest type2) (second type2) '*))
  660.                            (dims2 (if (cddr type2) (third type2) '*)))
  661.                        (and (or (eq el-type2 '*)
  662.                                 (and (not (eq el-type1 '*))
  663.                                      (equal (upgraded-array-element-type el-type1)
  664.                                             (upgraded-array-element-type el-type2)
  665.                             )   )    )
  666.                             (or (eq dims2 '*)
  667.                                 (and (listp dims1) (listp dims2)
  668.                                      (eql (length dims1) (length dims2))
  669.                                      (every #'(lambda (a b) (or (eq b '*) (= a b)))
  670.                                               dims1 dims2
  671.                     )) )    )   )    )
  672.                     (t nil)
  673.               )
  674.               t
  675.       ) ) ) )
  676.       (COMPLEX
  677.         (let* ((rtype1 (if (rest type1) (second type1) '*))
  678.                (itype1 (if (cddr type1) (third type1) rtype1)))
  679.           (values
  680.             (cond ((or (eq type2 'COMPLEX) (eq type2 'NUMBER)) t)
  681.                   ((and (consp type2) (eq (first type2) 'COMPLEX))
  682.                    (let* ((rtype2 (if (rest type2) (second type2) '*))
  683.                           (itype2 (if (cddr type2) (third type2) rtype2)))
  684.                      (and (or (eq rtype2 '*)
  685.                               (and (not (eq rtype1 '*))
  686.                                    (subtypep rtype1 rtype2)
  687.                           )   )
  688.                           (or (eq itype2 '*)
  689.                               (and (not (eq itype1 '*))
  690.                                    (subtypep itype1 itype2)
  691.                   )) )    )   )
  692.                   (t nil)
  693.             )
  694.             t
  695.       ) ) )
  696.       ((REAL INTEGER RATIONAL FLOAT SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
  697.         (let ((typelist
  698.                 (cons (first type1)
  699.                   (case (first type1)
  700.                     (REAL '(NUMBER))
  701.                     (INTEGER '(RATIONAL REAL NUMBER))
  702.                     ((RATIONAL FLOAT) '(REAL NUMBER))
  703.                     ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT) '(FLOAT REAL NUMBER))
  704.               ) ) )
  705.               (low1 (if (rest type1) (second type1) '*))
  706.               (high1 (if (cddr type1) (third type1) '*))
  707.               (integer-flag1 (eq (first type1) 'INTEGER))
  708.               (efl t)
  709.               (efh t))
  710.           (when (consp low1)
  711.             (setq low1 (first low1))
  712.             (if integer-flag1 (when (numberp low1) (incf low1)) (setq efl nil))
  713.           )
  714.           (when (consp high1)
  715.             (setq high1 (first high1))
  716.             (if integer-flag1 (when (numberp high1) (decf high1)) (setq efh nil))
  717.           )
  718.           ; efl gibt an, ob low1 zu type1 dazugehört.
  719.           ; efh gibt an, ob high1 zu type1 dazugehört.
  720.           (cond ((and (numberp low1) (numberp high1)
  721.                       (not (or (< low1 high1) (and (= low1 high1) efl efh)))
  722.                  ) ; type1 leer?
  723.                  (yes)
  724.                 )
  725.                 ((member type2 typelist) (yes))
  726.                 ((and (consp type2) (member (first type2) typelist))
  727.                  (let ((low2 (if (rest type2) (second type2) '*))
  728.                        (high2 (if (cddr type2) (third type2) '*))
  729.                        (integer-flag2 (eq (first type2) 'INTEGER)))
  730.                    (if (consp low2)
  731.                      (progn (setq low2 (first low2))
  732.                             (when integer-flag2 (when (numberp low2) (incf low2)) (setq efl nil))
  733.                      )
  734.                      (setq efl nil)
  735.                    )
  736.                    (if (consp high2)
  737.                      (progn (setq high2 (first high2))
  738.                             (when integer-flag2 (when (numberp high2) (decf high2)) (setq efh nil))
  739.                      )
  740.                      (setq efh nil)
  741.                    )
  742.                    ; efl gibt an, ob low1 zu type1 dazugehört und low2 zu type2 nicht dazugehört.
  743.                    ; efh gibt an, ob high1 zu type1 dazugehört und high2 zu type2 nicht dazugehört.
  744.                    (values
  745.                      (and (or (eq low2 '*)
  746.                               (and (numberp low1)
  747.                                    (if efl (> low1 low2) (>= low1 low2))
  748.                           )   )
  749.                           (or (eq high2 '*)
  750.                               (and (numberp high1)
  751.                                    (if efh (< high1 high2) (<= high1 high2))
  752.                      )    )   )
  753.                      t
  754.                 )) )
  755.                 (t (values nil (not integer-flag1)))
  756.       ) ) )
  757.       (t (unknown))
  758. ) ) )
  759.  
  760. ;; Bestimmt zwei Werte low,high so, daß (subtypep type `(INTEGER ,low ,high))
  761. ;; gilt und low möglichst groß und high möglichst klein ist.
  762. ;; low = * bedeutet -unendlich, high = * bedeutet unendlich.
  763. ;; Werte sind NIL,NIL falls (subtypep type 'INTEGER) falsch ist.
  764. ;; Wir brauchen diese Funktion nur für MAKE-ARRAY und UPGRADED-ARRAY-ELEMENT-TYPE,
  765. ;; dürfen also oBdA  type  durch  `(OR ,type (MEMBER 0))  ersetzen.
  766. (defun subtype-integer (type)
  767.   (macrolet ((yes () '(return-from subtype-integer (values low high)))
  768.              (no () '(return-from subtype-integer nil))
  769.              (unknown () '(return-from subtype-integer nil)))
  770.     (setq type (canonicalize-type type))
  771.     (if (consp type)
  772.       (macrolet ((min* (x y) `(if (or (eq ,x '*) (eq ,y '*)) '* (min ,x ,y)))
  773.                  (max* (x y) `(if (or (eq ,x '*) (eq ,y '*)) '* (max ,x ,y))))
  774.         (case (first type)
  775.           (MEMBER ;; MEMBER: alle Elemente müssen vom Typ INTEGER sein
  776.             (let ((low 0) (high 0)) ; oBdA!
  777.               (dolist (x (rest type) (yes))
  778.                 (unless (typep x 'INTEGER) (return (no)))
  779.                 (setq low (min low x) high (max high x))
  780.           ) ) )
  781.           (OR ;; OR: Jeder Typ muß Subtyp von INTEGER sein
  782.             (let ((low 0) (high 0)) ; oBdA!
  783.               (dolist (type1 (rest type) (yes))
  784.                 (multiple-value-bind (low1 high1) (subtype-integer type1)
  785.                   (unless low1 (return (no)))
  786.                   (setq low (min* low low1) high (max* high high1))
  787.           ) ) ) )
  788.           (AND ;; AND: Falls ein Typ Subtyp von INTEGER ist, sonst nicht bekannt
  789.             ;; Hier könnte man die verschiedenen Integer-Subtypen schneiden.
  790.             (dolist (type1 (rest type) (unknown))
  791.               (multiple-value-bind (low high) (subtype-integer type1)
  792.                 (when low (return (yes)))
  793.           ) ) )
  794.       ) )
  795.       (setq type (list type))
  796.     )
  797.     (if (eq (first type) 'INTEGER)
  798.       (let ((low (if (rest type) (second type) '*))
  799.             (high (if (cddr type) (third type) '*)))
  800.         (when (consp low)
  801.           (setq low (first low))
  802.           (when (numberp low) (incf low))
  803.         )
  804.         (when (consp high)
  805.           (setq high (first high))
  806.           (when (numberp high) (decf high))
  807.         )
  808.         (when (and (numberp low) (numberp high) (not (<= low high))) ; type leer?
  809.           (setq low 0 high 0)
  810.         )
  811.         (yes)
  812.       )
  813.       (unknown)
  814. ) ) )
  815.  
  816. #| Zu tun:
  817. SUBTYPEP so verbessern, daß
  818. (let ((l '(ARRAY BIT-VECTOR CHARACTER COMPLEX CONS FLOAT FUNCTION HASH-TABLE
  819.            INTEGER LIST NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIONAL
  820.            READTABLE REAL SEQUENCE CLOS:STANDARD-GENERIC-FUNCTION STREAM STRING
  821.            SYMBOL VECTOR
  822.      ))   )
  823.   (dolist (a l)
  824.     (dolist (b l)
  825.       (unless (or (subtypep a b) (subtypep b a))
  826.         (unless (equal (multiple-value-list (subtypep `(AND ,a ,b) 'NIL))
  827.                        '(nil t)
  828.                 )
  829.           (print (list a b))
  830. ) ) ) ) )
  831. möglichst wenig ausgibt.
  832. |#
  833.  
  834.